home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / defoma / libperl-file.pl < prev    next >
Text File  |  2006-06-17  |  937b  |  47 lines
  1. sub get_file_category {
  2.     my $file = shift;
  3.  
  4.     my $ret = `/usr/bin/file $file`;
  5.     chomp($ret);
  6.  
  7.     $ret = substr($ret, length($file) + 2);
  8.  
  9.     if ($ret eq 'ASCII text') {
  10.     if ($file =~ /\.hints$/) {
  11.         return 'hintfile';
  12.     }
  13.     } elsif ($ret =~ /PostScript/) {
  14.     if ($ret =~ /PostScript Type 1 font/) {
  15.         return 'type1';
  16.     } else {
  17.         if (open(F, $file)) {
  18.         my $l = scalar(<F>);
  19.         close F;
  20.         chomp($l);
  21.         if ($l =~ /Resource-CMap/) {
  22.             return 'cmap';
  23.         } elsif ($l =~ /Resource-Font/) {
  24.             return 'psfont';
  25.         } elsif ($l =~ /Resource-CIDFont/) {
  26.             return 'cid';
  27.         }
  28.         }
  29.         return 'unknown';
  30.     }
  31.     } elsif ($ret eq 'MS Windows TrueType font') {
  32.     return 'truetype';
  33.     } elsif ($ret eq 'data' && $file =~ /\.ttc/i) {
  34.     if (open(F, $file)) {
  35.         my $l = substr(scalar(<F>), 0, 4);
  36.         close F;
  37.         if ($l eq 'ttcf') {
  38.         return 'truetype';
  39.         }
  40.     }
  41.     return 'unknown';
  42.     }
  43.     return 'unknown';
  44. }
  45.     
  46. 1;
  47.